home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / tpb4_src.zip / UTILMNU1.PAS < prev    next >
Pascal/Delphi Source File  |  1988-09-13  |  16KB  |  485 lines
  1. { TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen  
  2.   Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault  
  3.   
  4.   Last modified  ::  9-2-88 10:39 pm 
  5. }
  6.  
  7. {$R-}                             {Range checking off}
  8. {$B-}                             {Boolean complete evaluation off}
  9. {$S-}                             {Stack checking off}
  10. {$I+}                             {I/O checking on}
  11. {$N-}                             {No numeric coprocessor}
  12.  
  13. Unit Utilmnu1;
  14.  
  15. Interface
  16.  
  17. Uses
  18.   TPCrt, Dos, Globals, TAccess,
  19.   Core1, Core2, TPSTRING,
  20.   Utilmnu2, Dirs;
  21.   
  22.   
  23. procedure display_users;
  24.  
  25. function chat   : Boolean;
  26.  
  27. procedure display_time;
  28.  
  29. procedure display_stats;
  30.  
  31. procedure alter_user_params;
  32.  
  33.  
  34.   {==========================================================================}
  35.   
  36.   
  37. Implementation
  38.  
  39.  
  40. { Set the system time using a 6 element byte array which contains
  41.   seconds, minutes, hours, day, month, and year.}
  42.   
  43.   procedure SetTAD(var t : tad_array);
  44.   
  45.   var
  46.     temp1, temp2, temp3, temp4 : Word;
  47.     
  48.   begin
  49.     temp4 := 0;                   { hundreths of seconds}
  50.     temp3 := t[0];                { seconds }
  51.     temp2 := t[1];                { minutes }
  52.     temp1 := t[2];                { hours }
  53.     SetTime(temp1, temp2, temp3, temp4);
  54.     
  55.     temp3 := t[3];                { day }
  56.     temp2 := t[4];                { month }
  57.     temp1 := t[5]+1900;           { year }
  58.     SetDate(temp1, temp2, temp3);
  59.     
  60.   end;
  61.   
  62.   
  63.   procedure display_users;
  64.     { Display user file }
  65.     
  66.   const
  67.     col_width       = 19;
  68.     
  69.   var
  70.     colend, count   : Integer;
  71.     i               : LongInt;
  72.     ch, disp_case,
  73.     disp_nois       : Char;
  74.     t               : tad_array;
  75.     key             : StrName;
  76.     temp_user_rec   : user_list;
  77.     Str             : StrTAD;
  78.     caller          : Boolean;
  79.     
  80.   begin                           {display users}
  81.     SetSect(HomName);
  82.     if user_rec.access >= 250 then
  83.       caller := False
  84.     else
  85.       caller := True;
  86.     repeat
  87.       if (not caller) then
  88.         begin
  89.           WriteLn(Com);
  90.           st := prompt('Type of list <A><B><E><Q><U><?> ', 80, 'ES?');
  91.           if Length(st) = 1 then
  92.             ch := st[1]
  93.           else
  94.             ch := ' ';
  95.           if not(ch in ['A', 'E', 'Q', 'U'])
  96.           then WriteLn(Com, '<A>ll, <B>rief, <E>xceptional, <U>n-validated, <Q>uit');
  97.         end
  98.       else
  99.         if user_rec.access >= val_acc then
  100.           ch := 'B'
  101.         else
  102.           ch := 'Q';
  103.       if ch in ['A', 'B', 'E', 'U'] then
  104.         begin
  105.           abort := False;
  106.           WriteLn(Com);
  107.           WriteLn(Com, 'The user list will be alphabetic by last name,');
  108.           WriteLn(Com, 'starting with a character or string you specify.');
  109.           WriteLn(Com);
  110.           key := prompt('Start [ <CR> for all names]', len_name, 'ES');
  111.           if key = ' ' then
  112.             begin
  113.               ClearKey(IdxF);
  114.               NextKey(IdxF, i, key)
  115.             end
  116.           else
  117.             begin
  118.               SearchKey(IdxF, i, key);
  119.               if not OK then
  120.                 begin
  121.                   ClearKey(IdxF);
  122.                   NextKey(IdxF, i, key)
  123.                 end
  124.             end;
  125.           GetTAD(t); count := 0;
  126.           Str := FormTAD(t);
  127.           if ch = 'E' then
  128.             WriteLn(Com, 'Exceptional - access, time, exempt from purge.')
  129.           else if ch = 'U' then
  130.             Write(Com, 'Unvalidated ');
  131.           WriteLn(Com, 'Users As Of: ', Str);
  132.           WriteLn(Com);
  133.           if (user_rec.lines <> 99) and (not printer_copy) then count := count+2;
  134.           if user_rec.access >= 250 then
  135.             begin
  136.               WriteLn(Com, FileLen(DatF), ' records, ');
  137.               if (user_rec.lines <> 99) and (not printer_copy) then Inc(count);
  138.             end;
  139.           if ch <> 'B' then WriteLn(Com, UsedRecs(DatF), ' users in file.');
  140.           if (user_rec.lines <> 99) and (not printer_copy) then
  141.             Inc(count);
  142.           colend := 999;
  143.           while (not brk) and OK do
  144.             with temp_user_rec do
  145.               begin
  146.                 GetRec(DatF, i, temp_user_rec);
  147.                 if (ch = 'B') and (fn <> 'SYSOP') and (access >= val_acc)
  148.                 then
  149.                   begin
  150.                     WriteLn(Com, pad(ln, Succ(len_ln)), ' ', pad(fn, Succ(len_fn)),
  151.                       '    ', pad(cy+',', len_cy+2), '   ', st);
  152.                     WriteLn(Com, 'Computer: ', pad(ad, Succ(len_ad)), ' Last on: ', laston
  153.                       [4],
  154.                       '/', laston[3], '/', laston[5]);
  155.                     WriteLn(Com);
  156.                     if (user_rec.lines <> 99) and (not printer_copy) then
  157.                       begin
  158.                         Inc(count, 3);
  159.                         if count >= user_rec.lines then
  160.                           begin
  161.                             pause; count := 0;
  162.                           end;
  163.                       end;
  164.                   end
  165.                 else if (ch = 'A')
  166.                 or ((ch = 'U') and (access < val_acc))
  167.                 or ((ch = 'E') and ((access > val_acc) or (limit > val_time)
  168.                   or test_bit(Flags, 5)))
  169.                 then if fn <> 'SYSOP' then
  170.                     begin
  171.                       WriteLn(Com);
  172.                       WriteLn(Com, {first line}
  173.                         ln, ' ', fn, '   ', cy, ',  ', st, '   ',
  174.                         pad(ph, Succ(len_ph)), '  ',
  175.                         pad(ad, Succ(len_ad)));
  176.                         
  177.                       WriteLn(Com, {second line}
  178.                         'Access:', access:4,
  179.                         '    Time Limit:', limit:4);
  180.                         
  181.                       if shift_lock
  182.                       then disp_case := 'U'
  183.                       else disp_case := 'L';
  184.                       if noisy
  185.                       then disp_nois := 'N'
  186.                       else disp_nois := 'Q';
  187.                       
  188.                       Write(Com,  {third line}
  189.                         'Nulls:', nulls:2,
  190.                         '    Case:', disp_case:2,
  191.                         '    Noisy:', disp_nois:2,
  192.                         '    Conferences:');
  193.                       if conf_flags > 0 then
  194.                         begin
  195.                           for i := 1 to 7 do
  196.                             if test_bit(conf_flags, i) then Write(Com, ' ', Chr(i+48));
  197.                           WriteLn(Com);
  198.                         end
  199.                       else WriteLn(Com, ' None');
  200.                       
  201.                       WriteLn(Com, {fourth line}
  202.                         'Cols:', columns:3,
  203.                         '   Lines:', lines:3,
  204.                         '   Last on: ', laston[4], '/', laston[3], '/', laston[5], ' ',
  205.                         '   Last msg read:', lasthi:5);
  206.                         
  207.                       Write(Com,  {fourth line}
  208.                         'Uplds:', upload:3,
  209.                         '    Downlds:', download:4,
  210.                         '   Password: ', pw,
  211.                         '   Flags set:');
  212.                       if Flags > 0 then
  213.                         begin
  214.                           for i := 0 to 7 do
  215.                             if test_bit(Flags, i) then Write(Com, ' ', Chr(i+48));
  216.                           WriteLn(Com);
  217.                         end
  218.                       else WriteLn(Com, ' None');
  219.                       
  220.                       if (user_rec.lines <> 99) and (not printer_copy) then
  221.                         begin
  222.                           count := count+6;
  223.                           if count >= user_rec.lines then
  224.                             begin
  225.                               pause; count := 0;
  226.                             end;
  227.                         end;
  228.                     end;
  229.                 NextKey(IdxF, i, key)
  230.               end;
  231.         end;                      {valid command}
  232.     until (ch = 'Q') or (not Online) or caller;
  233.   end;
  234.   
  235.   
  236.   function chat   : Boolean;
  237.     { Chat with sysop }
  238.     
  239.   var
  240.     Regs            : Dos.Registers;
  241.     ch              : Char;
  242.     i, count        : Integer;
  243.     n               : Word;
  244.     t               : tad_array;
  245.     Str             : StrStd;
  246.     
  247.   begin
  248.     chl := ' ';
  249.     OK := op_chat;
  250.     if op_chat
  251.     then WriteLn(Com, 'Chat requested by Sysop...', BEL, BEL)
  252.     else
  253.       begin
  254.         GetTAD(t);
  255.         if (not chat_ok) then
  256.           WriteLn(Com, 'Sorry, the Chat function is not active at this time.')
  257.         else
  258.           if (t[2] < chatstart) or (t[2] > Pred(chatend))
  259.           then WriteLn(Com, 'Sorry, the hours to chat are ', chatstart, ':00 to ', chatend,
  260.             ':00.')
  261.           else
  262.             begin
  263.               WriteLn(Com);
  264.               WriteLn(Com, 'Please standby ', user_rec.fn, ' ', user_rec.ln, '.');
  265.               WriteLn(Com, 'Will ring for 30 seconds.  Type ^C to cancel.');
  266.               WriteLn(Com);
  267.               Write(Com, '|-------------------------------|', CR, '|');
  268.               i := 15;
  269.               repeat
  270.                 Write(BEL, BEL);  { BEL is not normally sent to console }
  271.                 Write(Com, '-+', BEL);
  272.                 time_count := 0; count := 0;
  273.                 repeat
  274.                   ch := GetChar;
  275.                   Regs.AH := 0;
  276.                   Intr($1A, Regs);
  277.                   if Regs.AL <> 0 then
  278.                     Mem[40:70] := $1;
  279.                   n := Regs.DX;
  280.                   if n <> time_count then
  281.                     begin
  282.                       time_count := n;
  283.                       Inc(count);
  284.                     end;
  285.                 until (not Online) or (count > 36) or (ch in [ETX, ESC]);
  286.                 Dec(i);
  287.               until (not Online) or (i <= 0) or (ch in [ETX, ESC]);
  288.               WriteLn(Com);
  289.               if (ch in [ETX, ESC]) and (chl <> ESC)
  290.               then WriteLn(Com, 'Cancelled.')
  291.               else if chl = ESC
  292.               then
  293.                 begin
  294.                   WriteLn(Com, 'Sysop is available.  Type ^C to exit CHAT...');
  295.                   OK := True
  296.                 end
  297.               else WriteLn(Com, 'Sorry, the sysop is not available.')
  298.             end
  299.       end;
  300.     if OK then
  301.       begin
  302.         WriteLn(Com);
  303.         in_chat := True;
  304.         next_inpstr := '';
  305.         repeat
  306.           Str := next_inpstr;
  307.           GetStr(Str, ch, len_msg, 'AEW');
  308.           WriteLn(Com)
  309.         until (not Online) or (ch = ETX);
  310.         in_chat := False;
  311.         chat := False
  312.       end
  313.     else
  314.       begin
  315.         WriteLn(Com);
  316.         chat := ask('Would you care to leave a message', 'N')
  317.       end;
  318.   end;
  319.   
  320.   
  321.   procedure display_time;
  322.     { Display current system time and date }
  323.     
  324.   var
  325.     t, tem          : tad_array;
  326.     Str             : StrTAD;
  327.     
  328.   begin
  329.     GetTAD(t);
  330.     Str := FormTAD(t);
  331.     WriteLn(Com, Str);
  332.     if (user_rec.access >= 250) or (not remote_copy)
  333.     then if ask('Do you want to reset the time', 'N')
  334.       then
  335.         begin
  336.           WriteLn(Com);           { Change login time so system doesn't hang up on us }
  337.           tem[5] := strint(prompt('Year  ', 2, 'E'));
  338.           tem[4] := strint(prompt('Month ', 2, 'E'));
  339.           tem[3] := strint(prompt('Day   ', 2, 'E'));
  340.           tem[2] := strint(prompt('Hour  ', 2, 'E'));
  341.           tem[1] := strint(prompt('Minute', 2, 'E'));
  342.           tem[0] := strint(prompt('Second', 2, 'E'));
  343.           SetTAD(tem);
  344.           GetTAD(login_t);
  345.           Str := FormTAD(login_t);
  346.           WriteLn(Com, Str);
  347.         end;
  348.   end;
  349.   
  350.   
  351.   procedure display_stats;
  352.   
  353.   var
  354.     i, days, max    : Integer;
  355.     t               : tad_array;
  356.     day_array       : array[0..23] of Integer;
  357.     
  358.     
  359.     procedure show_graph(title : StrPr);
  360.     
  361.     var
  362.       i, J            : Integer;
  363.       factor, scale   : Real;
  364.       line            : StrStd;
  365.       
  366.     begin
  367.       WriteLn(Com);
  368.       WriteLn(Com, ' ':8, title, ' for the Last ', days, ' Days');
  369.       WriteLn(Com);
  370.       factor := max/15.0;
  371.       for J := 15 downto 1 do
  372.         begin
  373.           line := '                                                                       ';
  374.           scale := factor*J;
  375.           for i := 0 to 23 do
  376.             if day_array[i] > scale
  377.             then
  378.               begin
  379.                 line[1+3*i] := '*';
  380.                 line[2+3*i] := '*'
  381.               end;
  382.           Write(Com, white, scale:3:0);
  383.           i := Length(line);
  384.           while line[i] = ' ' do
  385.             i := Pred(i);
  386.           WriteLn(Com, ' ', yellow, Copy(line, 1, i))
  387.         end;
  388.       Write(Com, white);
  389.       WriteLn(Com, '    12  1  2  3  4  5  6  7  8  9 10 11 12  1  2  3  4  5  6  7  8  9 10 11')
  390.       ;
  391.       Write(Com, green);
  392.       WriteLn(Com, '    |------------- A. M. ---------------|------------- P. M. -------------|')
  393.       ;
  394.     end;
  395.     
  396.   begin                           { show_stats }
  397.     GetTAD(t);
  398.     days := Round(greg_to_jul(t[3], t[4], t[5])-greg_to_jul(stat_rec.date[3],
  399.       stat_rec.date[4], stat_rec.date[5]));
  400.     if days = 0
  401.     then days := 1;
  402.     max := 0;
  403.     for i := 0 to 23 do
  404.       begin
  405.         day_array[i] := Round((100.0*stat_rec.busy_per_hour[i])/(60.0*days));
  406.         if max < day_array[i]
  407.         then max := day_array[i]
  408.       end;
  409.     show_graph('Percent of Average System Usage by Hour')
  410.   end;
  411.   
  412.   
  413.   procedure alter_user_params;
  414.     { Get new user parameters }
  415.     
  416.   var
  417.     valid,
  418.     continue        : Boolean;
  419.     ch              : Char;
  420.     i               : Integer;
  421.     temp            : string[2];
  422.     
  423.   begin
  424.     repeat
  425.       continue := False;
  426.       WriteLn(Com);
  427.       st := prompt('Parameter <B><C><L><N><P><S><#><Q><?> ', 80, 'ES?');
  428.       WriteLn(Com);
  429.       if Length(st) = 1 then ch := st[1]
  430.       else ch := '?';
  431.       case ch of
  432.         'B' :
  433.           begin
  434.             user_rec.noisy := not user_rec.noisy;
  435.             if user_rec.noisy
  436.             then WriteLn(Com, 'Prompt bell on.')
  437.             else WriteLn(Com, 'Prompt bell off.')
  438.           end;
  439.         'C' :
  440.           begin
  441.             WriteLn(Com, 'Current characters per line setting is ', user_rec.columns, '.');
  442.             temp := prompt('New setting [40-80]', 2, 'ES');
  443.             i := strint(temp);
  444.             if (temp = ' ') or (not(i in [40..80]))
  445.             then WriteLn(Com, 'Characters per line unchanged.')
  446.             else user_rec.columns := i
  447.           end;
  448.         'L' :
  449.           begin
  450.             WriteLn(Com, 'Current lines-per-page setting is ', user_rec.lines, '.');
  451.             temp := prompt('New setting [10-48 or 99 to inhibit pause]', 2, 'ES');
  452.             i := strint(temp);
  453.             if (temp = ' ') or (not(i in [10..48, 99]))
  454.             then WriteLn(Com, 'Lines-per-page unchanged.')
  455.             else user_rec.lines := i
  456.           end;
  457.         'N' :
  458.           begin
  459.             WriteLn(Com, 'Currently using ', user_rec.nulls, ' nulls.');
  460.             get_nulls
  461.           end;
  462.         'P' :
  463.           begin
  464.             get_old_password('Please enter current password', valid);
  465.             if valid
  466.             then get_new_password
  467.             else WriteLn(Com, 'Password unchanged.')
  468.           end;
  469.         '#' : get_phone;
  470.         'Q' : continue := True;
  471.         'S' : get_case
  472.       else
  473.         begin
  474.           list('C');
  475.           continue := False;
  476.         end;
  477.       end;
  478.     until (continue) or (not Online);
  479.     if Online then PutRec(DatF, user_loc, user_rec);
  480.   end;
  481.   
  482.   
  483. end.                              { of UTILMNU1.PAS }
  484. 
  485.